home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
c
/
eval.c
< prev
next >
Wrap
C/C++ Source or Header
|
1987-06-04
|
17KB
|
986 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
eval.c
*/
#include "include.h"
struct nil3 { object nil3_self[3]; } three_nils;
#undef endp
#define endp(obje) ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
FALSE : endp_temp == Cnil ? TRUE : \
(bool)FEwrong_type_argument(Slist, endp_temp))
object endp_temp;
int eval1 = 0;
object Vevalhook;
object Vapplyhook;
static object temporary;
object Sapply;
object Sfuncall;
funcall(fun)
object fun;
{
object x;
object *top, *lex;
bds_ptr old_bds_top;
bool b, c;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
MMcall(fun);
return;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
MMccall(fun, fun->cc.cc_turbo);
return;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
MMccall(fun, top);
return;
}
case t_cons:
break;
default:
FEinvalid_function(fun);
}
/*
This part is the same as that of funcall_no_event.
*/
ihs_check;
ihs_push(fun);
ihs_top->ihs_base = lex_env;
x = MMcar(fun);
top = vs_top;
lex = lex_env;
old_bds_top = bds_top;
if (x == Slambda_block) {
b = TRUE;
c = FALSE;
fun = fun->c.c_cdr;
} else if (x == Slambda_closure) {
b = FALSE;
c = TRUE;
fun = fun->c.c_cdr;
} else if (x == Slambda) {
b = c = FALSE;
fun = fun->c.c_cdr;
} else if (x == Slambda_block_closure) {
b = c = TRUE;
fun = fun->c.c_cdr;
} else
b = c = TRUE;
if (c) {
vs_push(kar(fun));
fun = fun->c.c_cdr;
vs_push(kar(fun));
fun = fun->c.c_cdr;
vs_push(kar(fun));
fun = fun->c.c_cdr;
} else {
*(struct nil3 *)vs_top = three_nils;
vs_top += 3;
}
if (b) {
x = kar(fun); /* block name */
fun = fun->c.c_cdr;
}
lex_env = top;
vs_push(fun);
lambda_bind(top);
ihs_top->ihs_base = lex_env;
if (b) {
fun = temporary = alloc_frame_id();
/* lex_block_bind(x, temporary); */
temporary = MMcons(temporary, Cnil);
temporary = MMcons(Sblock, temporary);
temporary = MMcons(x, temporary);
lex_env[2] = MMcons(temporary, lex_env[2]);
frs_push(FRS_CATCH, fun);
if (nlj_active) {
nlj_active = FALSE;
goto END;
}
}
x = top[3]; /* body */
if(endp(x)) {
vs_base = vs_top;
vs_push(Cnil);
} else {
top = vs_top;
for (;;) {
eval(MMcar(x));
x = MMcdr(x);
if (endp(x))
break;
vs_top = top;
}
}
END:
if (b)
frs_pop();
bds_unwind(old_bds_top);
lex_env = lex;
ihs_pop();
}
funcall_no_event(fun)
object fun;
{
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
(*fun->cf.cf_self)();
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
(*fun->cc.cc_self)(fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
(*fun->cc.cc_self)(top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
}
lispcall(funp, narg)
object *funp;
int narg;
{
object fun = *funp;
vs_base = funp + 1;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
MMcall(fun);
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
MMccall(fun, fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
MMccall(fun, top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
}
lispcall_no_event(funp, narg)
object *funp;
int narg;
{
object fun = *funp;
vs_base = funp + 1;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
(*fun->cf.cf_self)();
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
(*fun->cc.cc_self)(fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
(*fun->cc.cc_self)(top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
}
symlispcall(sym, base, narg)
object sym, *base;
int narg;
{
object fun = symbol_function(sym);
vs_base = base;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
MMcall(fun);
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
MMccall(fun, fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
MMccall(fun, top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
}
symlispcall_no_event(sym, base, narg)
object sym, *base;
int narg;
{
object fun = symbol_function(sym);
vs_base = base;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
(*fun->cf.cf_self)();
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
(*fun->cc.cc_self)(fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
(*fun->cc.cc_self)(top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
}
object
simple_lispcall(funp, narg)
object *funp;
int narg;
{
object fun = *funp;
object *sup = vs_top;
vs_base = funp + 1;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
MMcall(fun);
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
MMccall(fun, fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
MMccall(fun, top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
vs_top = sup;
return(vs_base[0]);
}
object
simple_lispcall_no_event(funp, narg)
object *funp;
int narg;
{
object fun = *funp;
object *sup = vs_top;
vs_base = funp + 1;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
(*fun->cf.cf_self)();
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
(*fun->cc.cc_self)(fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
(*fun->cc.cc_self)(top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
vs_top = sup;
return(vs_base[0]);
}
object
simple_symlispcall(sym, base, narg)
object sym, *base;
int narg;
{
object fun = symbol_function(sym);
object *sup = vs_top;
vs_base = base;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
MMcall(fun);
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
MMccall(fun, fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
MMccall(fun, top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
vs_top = sup;
return(vs_base[0]);
}
object
simple_symlispcall_no_event(sym, base, narg)
object sym, *base;
int narg;
{
object fun = symbol_function(sym);
object *sup = vs_top;
vs_base = base;
vs_top = vs_base + narg;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
case t_cfun:
(*fun->cf.cf_self)();
break;
case t_cclosure:
{
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
(*fun->cc.cc_self)(fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
(*fun->cc.cc_self)(top);
break;
}
case t_cons:
funcall(fun);
break;
default:
FEinvalid_function(fun);
}
vs_top = sup;
return(vs_base[0]);
}
super_funcall(fun)
object fun;
{
if (type_of(fun) == t_symbol) {
if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
FEinvalid_function(fun);
if (fun->s.s_gfdef == OBJNULL)
FEundefined_function(fun);
fun = fun->s.s_gfdef;
}
funcall(fun);
}
super_funcall_no_event(fun)
object fun;
{
if (type_of(fun) == t_symbol) {
if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
FEinvalid_function(fun);
if (fun->s.s_gfdef == OBJNULL)
FEundefined_function(fun);
fun = fun->s.s_gfdef;
}
funcall_no_event(fun);
}
eval(form)
object form;
{
object fun, x;
object *top;
object *base;
cs_check(form);
EVAL:
vs_check;
if (Vevalhook->s.s_dbind != Cnil && eval1 == 0)
{
bds_ptr old_bds_top = bds_top;
object hookfun = symbol_value(Vevalhook);
/* check if Vevalhook is unbound */
bds_bind(Vevalhook, Cnil);
vs_base = vs_top;
vs_push(form);
vs_push(lex_env[0]);
vs_push(lex_env[1]);
vs_push(lex_env[2]);
vs_push(Cnil);
stack_cons();
stack_cons();
stack_cons();
super_funcall(hookfun);
bds_unwind(old_bds_top);
return;
} else
eval1 = 0;
if (type_of(form) == t_cons)
goto APPLICATION;
if (type_of(form) != t_symbol) {
vs_base = vs_top;
vs_push(form);
return;
}
SYMBOL:
switch (form->s.s_stype) {
case stp_constant:
vs_base = vs_top;
vs_push(form->s.s_dbind);
return;
case stp_special:
if(form->s.s_dbind == OBJNULL)
FEunbound_variable(form);
vs_base = vs_top;
vs_push(form->s.s_dbind);
return;
default:
/* x = lex_var_sch(form); */
for (x = lex_env[0]; type_of(x) == t_cons; x = x->c.c_cdr)
if (x->c.c_car->c.c_car == form) {
x = x->c.c_car->c.c_cdr;
if (endp(x))
break;
vs_base = vs_top;
vs_push(x->c.c_car);
return;
}
if(form->s.s_dbind == OBJNULL)
FEunbound_variable(form);
vs_base = vs_top;
vs_push(form->s.s_dbind);
return;
}
APPLICATION:
fun = MMcar(form);
if (type_of(fun) != t_symbol)
goto LAMBDA;
if (fun->s.s_sfdef != NOT_SPECIAL) {
ihs_check;
ihs_push(fun);
ihs_top->ihs_base = lex_env;
(*fun->s.s_sfdef)(MMcdr(form));
ihs_pop();
return;
}
/* x = lex_fd_sch(fun); */
for (x = lex_env[1]; type_of(x) == t_cons; x = x->c.c_cdr)
if (x->c.c_car->c.c_car == fun) {
x = x->c.c_car;
if (MMcadr(x) == Smacro) {
x = MMcaddr(x);
goto EVAL_MACRO;
}
x = MMcaddr(x);
goto EVAL_ARGS;
}
GFDEF:
if ((x = fun->s.s_gfdef) == OBJNULL)
FEundefined_function(fun);
if (fun->s.s_mflag) {
EVAL_MACRO:
top = vs_top;
macro_expand1(x, form);
form = vs_base[0];
vs_top = top;
vs_push(form);
goto EVAL;
}
EVAL_ARGS:
vs_push(x);
form = form->c.c_cdr;
base = vs_top;
top = vs_top;
while(!endp(form)) {
eval(MMcar(form));
top[0] = vs_base[0];
vs_top = ++top;
form = MMcdr(form);
}
vs_base = base;
if (Vapplyhook->s.s_dbind != Cnil) {
call_applyhook(fun);
return;
}
if (type_of(x) == t_cfun) {
MMcall(x);
} else
funcall(x);
return;
LAMBDA:
if (type_of(fun) == t_cons && MMcar(fun) == Slambda) {
temporary = make_cons(lex_env[2], fun->c.c_cdr);
temporary = make_cons(lex_env[1], temporary);
temporary = make_cons(lex_env[0], temporary);
x = make_cons(Slambda_closure, temporary);
vs_push(x);
goto EVAL_ARGS;
}
FEinvalid_function(fun);
}
call_applyhook(fun)
object fun;
{
object ah;
object *v;
ah = symbol_value(Vapplyhook);
v = vs_base + 1;
vs_push(Cnil);
while (vs_top > v)
stack_cons();
vs_push(vs_base[0]);
vs_base[0] = fun;
vs_push(lex_env[0]);
vs_push(lex_env[1]);
vs_push(lex_env[2]);
vs_push(Cnil);
stack_cons();
stack_cons();
stack_cons();
super_funcall(ah);
}
Lfuncall()
{
if (vs_top-vs_base < 1)
too_few_arguments();
vs_base++;
super_funcall(vs_base[-1]);
}
Lapply()
{
object lastarg;
if (vs_top-vs_base < 2)
too_few_arguments();
lastarg = vs_pop;
while (!endp(lastarg)) {
vs_push(MMcar(lastarg));
lastarg = MMcdr(lastarg);
}
vs_base++;
super_funcall(vs_base[-1]);
}
Leval()
{
object *lex = lex_env;
check_arg(1);
lex_new();
eval(vs_base[0]);
lex_env = lex;
}
Levalhook()
{
object env;
bds_ptr old_bds_top = bds_top;
object *lex = lex_env;
int n = vs_top - vs_base;
lex_env = vs_top;
if (n < 3)
too_few_arguments();
else if (n == 3) {
*(struct nil3 *)vs_top = three_nils;
vs_top += 3;
} else if (n == 4) {
env = vs_base[3];
vs_push(car(env));
env = cdr(env);
vs_push(car(env));
env = cdr(env);
vs_push(car(env));
} else
too_many_arguments();
bds_bind(Vevalhook, vs_base[1]);
bds_bind(Vapplyhook, vs_base[2]);
eval1 = 1;
eval(vs_base[0]);
lex_env = lex;
bds_unwind(old_bds_top);
}
Lapplyhook()
{
object env;
bds_ptr old_bds_top = bds_top;
object *lex = lex_env;
int n = vs_top - vs_base;
object l, *z;
lex_env = vs_top;
if (n < 4)
too_few_arguments();
else if (n == 4) {
*(struct nil3 *)vs_top = three_nils;
vs_top += 3;
} else if (n == 5) {
env = vs_base[4];
vs_push(car(env));
env = cdr(env);
vs_push(car(env));
env = cdr(env);
vs_push(car(env));
} else
too_many_arguments();
bds_bind(Vevalhook, vs_base[2]);
bds_bind(Vapplyhook, vs_base[3]);
z = vs_top;
for (l = vs_base[1]; !endp(l); l = l->c.c_cdr)
vs_push(l->c.c_car);
l = vs_base[0];
vs_base = z;
super_funcall(l);
lex_env = lex;
bds_unwind(old_bds_top);
}
Lconstantp()
{
enum type x;
check_arg(1);
x = type_of(vs_base[0]);
if(x == t_cons)
if(vs_base[0]->c.c_car == Squote)
vs_base[0] = Ct;
else vs_base[0] = Cnil;
else if(x == t_symbol)
if((enum stype)vs_base[0]->s.s_stype == stp_constant)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
else
vs_base[0] = Ct;
}
object
ieval(x)
object x;
{
object *old_vs_base;
object *old_vs_top;
old_vs_base = vs_base;
old_vs_top = vs_top;
eval(x);
x = vs_base[0];
vs_base = old_vs_base;
vs_top = old_vs_top;
return(x);
}
object
ifuncall1(fun, arg1)
object fun, arg1;
{
object *old_vs_base;
object *old_vs_top;
object x;
old_vs_base = vs_base;
old_vs_top = vs_top;
vs_base = vs_top;
vs_push(arg1);
super_funcall(fun);
x = vs_base[0];
vs_top = old_vs_top;
vs_base = old_vs_base;
return(x);
}
object
ifuncall2(fun, arg1, arg2)
object fun, arg1, arg2;
{
object *old_vs_base;
object *old_vs_top;
object x;
old_vs_base = vs_base;
old_vs_top = vs_top;
vs_base = vs_top;
vs_push(arg1);
vs_push(arg2);
super_funcall(fun);
x = vs_base[0];
vs_top = old_vs_top;
vs_base = old_vs_base;
return(x);
}
object
ifuncall3(fun, arg1, arg2, arg3)
object fun, arg1, arg2, arg3;
{
object *old_vs_base;
object *old_vs_top;
object x;
old_vs_base = vs_base;
old_vs_top = vs_top;
vs_base = vs_top;
vs_push(arg1);
vs_push(arg2);
vs_push(arg3);
super_funcall(fun);
x = vs_base[0];
vs_top = old_vs_top;
vs_base = old_vs_base;
return(x);
}
funcall_with_catcher(fname, fun)
object fname, fun;
{
int n = vs_top - vs_base;
if (n > 64) n = 64;
frs_push(FRS_CATCH, make_cons(fname, make_fixnum(n)));
if (nlj_active)
nlj_active = FALSE;
else
funcall(fun);
frs_pop();
}
init_eval()
{
make_constant("CALL-ARGUMENTS-LIMIT", make_fixnum(64));
Sapply = make_function("APPLY", Lapply);
enter_mark_origin(&Sapply);
Sfuncall = make_function("FUNCALL", Lfuncall);
enter_mark_origin(&Sfuncall);
Vevalhook = make_special("*EVALHOOK*", Cnil);
Vapplyhook = make_special("*APPLYHOOK*", Cnil);
temporary = Cnil;
enter_mark_origin(&temporary);
three_nils.nil3_self[0] = Cnil;
three_nils.nil3_self[1] = Cnil;
three_nils.nil3_self[2] = Cnil;
make_function("EVAL", Leval);
make_function("EVALHOOK", Levalhook);
make_function("APPLYHOOK", Lapplyhook);
make_function("CONSTANTP", Lconstantp);
}